home *** CD-ROM | disk | FTP | other *** search
/ SPACE 1 / SPACE - Library 1 - Volume 1.iso / games / 223 / accent / accentob.mod < prev    next >
Text File  |  1988-02-07  |  12KB  |  413 lines
  1. IMPLEMENTATION MODULE AccentObjects;
  2.  (* dialog box manipulation for Accent *)
  3.  
  4. (* Copyright 1987,1988 Ken Badertscher
  5.  * Permission is granted to freely use this program and source code,
  6.  * however it may NOT be used or modified for any commercial gain.
  7.  * The author disclaims responsibility for any damages resulting
  8.  * from the use or misuse of this program, and disclaims liability
  9.  * for losses of any kind or nature, financial or otherwise,
  10.  * incurred as a result of the use of this software.
  11.  *)
  12.  
  13. FROM SYSTEM IMPORT ADDRESS, ADR, INLINE, SHORT, REG;
  14.  
  15. FROM AccentStrings IMPORT AccentString;
  16.  
  17. FROM Terminal IMPORT Write, WriteString, WriteLn;
  18.  
  19. FROM AEStuff IMPORT
  20.    (* CONST *) AESError, InitError, SCREEN, WfWorkxywh, RTree, RObject,
  21.                FmdStart, FmdGrow, FmdShrink, FmdFinish,
  22.                Arrow,MOff,MOn;
  23.  
  24. FROM AESApplications IMPORT ApplInit, ApplExit;
  25. FROM AESGraphics     IMPORT GrafHandle, GrafMouse;
  26. FROM AESWindows      IMPORT WindGet;
  27. FROM AESResource     IMPORT RsrcLoad, RsrcGAddr, RsrcFree;
  28. FROM AESForms        IMPORT FormAlert, FormCenter, FormDial, FormDo;
  29. FROM AESObjects      IMPORT ObjcDraw, ObjcChange;
  30. FROM AESFileSelector IMPORT FselInput;
  31.  
  32. CONST (* Resource constants *)
  33.  
  34.       OUTPUT    = 0;      (* TREE *)
  35.       OPTIONSC  = 1;      (* TREE *)
  36.       OPTIONSM  = 2;      (* TREE *)
  37.       INFO      = 3;      (* TREE *)
  38.  
  39.       OUTSCRN   = 1;      (* OBJECT in TREE #0 *)
  40.       OUTDISK   = 2;      (* OBJECT in TREE #0 *)
  41.       OUTPRINT  = 3;      (* OBJECT in TREE #0 *)
  42.  
  43.       STUT      = 2;      (* OBJECT in TREE #1 *)
  44.       PIG       = 3;      (* OBJECT in TREE #1 *)
  45.       NERD      = 4;      (* OBJECT in TREE #1 *)
  46.       LISP      = 5;      (* OBJECT in TREE #1 *)
  47.       JAP       = 6;      (* OBJECT in TREE #1 *)
  48.       CENSOR    = 7;      (* OBJECT in TREE #1 *)
  49.       CHINESE   = 8;      (* OBJECT in TREE #1 *)
  50.       COCKNEY   = 9;      (* OBJECT in TREE #1 *)
  51.       GERMAN    = 10;      (* OBJECT in TREE #1 *)
  52.       ITALIAN   = 11;      (* OBJECT in TREE #1 *)
  53.       RANDOM    = 13;      (* OBJECT in TREE #1 *)
  54.       DOIT      = 14;      (* OBJECT in TREE #1 *)
  55.  
  56.       INFOEXIT  = 3;      (* OBJECT in TREE #3 *)
  57.  
  58.       D0      = 0;
  59.       pop     = 4FEFH;
  60.       term0   = 0;
  61.       prstat  = 11H;
  62.       setdrv  = 0EH;
  63.       getdrv  = 19H;
  64.       setpath = 3BH;
  65.       getpath = 47H;
  66.  
  67.       TrapGEMDOS = 4E41H;
  68.  
  69. PROCEDURE Dgetpath(drive: INTEGER; buf: ADDRESS; fnID: INTEGER);
  70.   CODE TrapGEMDOS;
  71.  
  72. PROCEDURE Dsetdrv(drive: INTEGER; fnID: INTEGER); CODE TrapGEMDOS;
  73.  
  74. PROCEDURE GEMDOSfn(fnID: INTEGER); CODE TrapGEMDOS;
  75.  
  76. VAR
  77.     (* trees *)
  78.     outputTree, optionsTree, infoTree : ADDRESS;
  79.  
  80.     i, optionsIndex,
  81.     gHandle, charW, charH, boxW, boxH, boxX, boxY,
  82.     scrnX, scrnY, scrnW, scrnH,
  83.     formX, formY, formW, formH : INTEGER;
  84.  
  85.     saveDrive   : INTEGER;
  86.     savePath,
  87.     saveFile    : AccentString;
  88.     accentOptions : BITSET;
  89.  
  90.     accentChoices : ARRAY [STUT..RANDOM] OF CHAR;
  91.  
  92. (*================================================================*)
  93.  
  94. PROCEDURE append(VAR start, end : ARRAY OF CHAR; at : INTEGER);
  95. (* append 'end' to 'start' beginning with character 'at'
  96.  * 'end' MUST BE NULL TERMINATED!
  97.  *   NO length check is performed on 'start', and a null is appended.
  98.  *)
  99.   VAR pos,len: INTEGER;
  100.   BEGIN
  101.     len := HIGH(end);
  102.     pos := 0;
  103.     WHILE (pos <= len)AND(end[pos] # 0C) DO
  104.        start[pos + at] := end[pos];
  105.        INC(pos);
  106.     END;
  107.     start[pos + at] := 0C;
  108.   END append;
  109.  
  110. (*----------------------------------------------------------------*)
  111.  
  112. PROCEDURE crash(str : ARRAY OF CHAR);
  113. (* Crash gracefully, with an informative alert *)
  114.   VAR
  115.     alert, alertend : ARRAY [0..79] OF CHAR;
  116.   BEGIN
  117.     alert := '[1][ ';
  118.     alertend := ' error ][ arf ]';
  119.     append(alert, str, 5);
  120.     append(alert, alertend, 6 + HIGH(str));
  121.     i := FormAlert(1, alert);
  122.     GEMTerm;
  123.   END crash;
  124.  
  125. (*----------------------------------------------------------------*)
  126.  
  127.  
  128. PROCEDURE DoDial(VAR num: INTEGER; tree: ADDRESS);
  129. (* on entry, 'num' contains object index to draw in 'tree'
  130.  * on exit, it contains the index of the object causing the exit
  131.  * from the form.
  132.  *)
  133.    VAR
  134.     numbits: BITSET;
  135.     doubleclick: BOOLEAN;
  136.    BEGIN
  137.       (* get dimensions and draw the form *)
  138.       IF FormCenter(tree, formX, formY, formW, formH) = AESError THEN
  139.          crash("FormCenter") END;
  140.       i := FormDial(FmdStart,
  141.                boxX, boxY, boxW, boxH,
  142.                formX,formY,formW,formH);
  143.       i := FormDial(FmdGrow,
  144.                boxX, boxY, boxW, boxH,
  145.                formX,formY,formW,formH);
  146.       i := ObjcDraw(tree, 0, 10, formX, formY, formW, formH);
  147.  
  148.  
  149.       (* form interaction.  bits in 'accentOptions' are set/cleared
  150.        * during interaction with Options tree
  151.        *)
  152.       IF tree # optionsTree THEN
  153.         numbits := VAL(BITSET,FormDo(tree, 0));
  154.         (* check the high bit (set if exit object double-clicked) *)
  155.         IF (15 IN numbits) THEN EXCL(numbits,15) END;
  156.         num := VAL(INTEGER,numbits);
  157.         (* change exit object state back to NORMAL *)
  158.     i := ObjcChange(tree,num,0,0,0,0,0,0,0);
  159.       ELSE
  160.         LOOP
  161.           numbits := VAL(BITSET,FormDo(tree,0));
  162.           IF (15 IN numbits) THEN (* object double-clicked *)
  163.             EXCL(numbits,15);
  164.             doubleclick := TRUE;
  165.           END;
  166.           i := VAL(INTEGER,numbits);
  167.           IF i = DOIT THEN i := ObjcChange(tree, DOIT, 0,0,0,0,0,0,0); EXIT;
  168.           ELSIF (VAL(CARDINAL,i) IN accentOptions) THEN
  169.             EXCL(accentOptions,VAL(CARDINAL,i))
  170.           ELSE
  171.             INCL(accentOptions,VAL(CARDINAL,i))
  172.           END;
  173.           IF doubleclick THEN doubleclick := FALSE; EXIT END;
  174.         END;
  175.       END;
  176.             
  177.       (* clean 'er up *)
  178.       i := FormDial(FmdShrink,
  179.                boxX, boxY, boxW, boxH,
  180.                formX,formY,formW,formH);
  181.       i := FormDial(FmdFinish,
  182.                boxX, boxY, boxW, boxH,
  183.            formX,formY,formW,formH);
  184.  
  185.    END DoDial;
  186.  
  187. (*----------------------------------------------------------------*)
  188.  
  189. PROCEDURE ClearScreen;
  190. (* hide the mouse and do a VT-52 clearscreen *)
  191.   BEGIN
  192.     i := GrafMouse(MOff,NIL);
  193.     Write(33C); Write('E');
  194.   END ClearScreen;
  195.  
  196.  
  197. (*----------------------------------------------------------------*)
  198. PROCEDURE GetDefaults;
  199.   VAR drv: INTEGER;
  200.   BEGIN
  201.     (* get current drive *)
  202.     GEMDOSfn(getdrv);
  203.     INLINE(pop,2);
  204.     drv := SHORT(REG(D0));
  205.     savePath := "A:";
  206.     savePath[0] := CHR( ORD(savePath[0]) + drv );
  207.  
  208.     (* get default path on current drive *)
  209.     Dgetpath(0,ADR(saveFile),getpath);
  210.     INLINE(pop,8);
  211.     append(savePath,saveFile,2);
  212.     (* add default extender *)
  213.     saveFile := "\*.TXT";
  214.     i := 0; REPEAT INC(i) UNTIL savePath[i] = 0C;
  215.     append(savePath,saveFile,i);
  216.     saveFile := "";
  217.   END GetDefaults;
  218.  
  219. (*================================================================*)
  220.  
  221. PROCEDURE DoAlert(defbuttn: INTEGER; str: ARRAY OF CHAR): INTEGER;
  222.   VAR ret: INTEGER;
  223.   BEGIN
  224.     ret := GrafMouse(MOn,NIL);
  225.     ret := FormAlert(defbuttn,str);
  226.     ClearScreen;
  227.     RETURN ret;
  228.   END DoAlert;
  229.  
  230. (*----------------------------------------------------------------*)
  231.  
  232. PROCEDURE ShowTitle;
  233.   VAR button: INTEGER;
  234.   BEGIN
  235.     IF ApplInit() = InitError THEN
  236.       crash("ApplInit")
  237.     ELSE
  238.       (* get resolution *)
  239.       gHandle := GrafHandle(charW, charH, boxW, boxH);
  240.       IF WindGet(SCREEN, WfWorkxywh,
  241.                  scrnX, scrnY, scrnW, scrnH) = AESError THEN
  242.         crash("WindGet")
  243.       END;
  244.  
  245.       (* check resolution -- no low rez *)
  246.       IF scrnW > 320 THEN
  247.         IF scrnH > 200 THEN (* mono *)
  248.           optionsIndex := OPTIONSM
  249.         ELSE
  250.           optionsIndex := OPTIONSC
  251.         END
  252.       ELSE
  253.         i := FormAlert(1,"[3][Medium or High rez please...][Oh, alright]");
  254.         GEMTerm;
  255.       END;
  256.  
  257.       (* find center-screen box coordinates *)
  258.       boxX := scrnX + (scrnW DIV 2);
  259.       boxY := scrnY + (scrnH DIV 2);
  260.  
  261.       (* get the resource *)
  262.       IF RsrcLoad(ADR("accent.rsc")) = AESError THEN
  263.         crash("accent.rsc not found -- ")
  264.       END;
  265.  
  266.       (* change mouse to an arrow, and hide it *)
  267.       i := GrafMouse(Arrow, NIL);
  268.       i := GrafMouse(MOff,NIL);
  269.  
  270.       accentOptions := {};
  271.  
  272.       accentChoices[STUT]   := 'S';
  273.       accentChoices[PIG]    := 'P';
  274.       accentChoices[NERD]   := 'D';
  275.       accentChoices[LISP]   := 'L';
  276.       accentChoices[JAP]    := 'J';
  277.       accentChoices[CENSOR] := 'O';
  278.       accentChoices[CHINESE]:= 'C';
  279.       accentChoices[COCKNEY]:= 'K';
  280.       accentChoices[GERMAN] := 'G';
  281.       accentChoices[ITALIAN]:= 'I';
  282.       accentChoices[RANDOM] := 'R';
  283.  
  284.       (* show the title dialog *)
  285.       IF RsrcGAddr(RTree, INFO, infoTree) = AESError THEN
  286.         crash("RsrcGAddr")
  287.       END;
  288.       i := GrafMouse(MOn,NIL);
  289.       button := INFO;
  290.       DoDial(button,infoTree);
  291.       ClearScreen;
  292.  
  293.     END; (* IF ApplInit() *)
  294.  
  295.   END ShowTitle;
  296.  
  297. (*----------------------------------------------------------------*)
  298.  
  299. PROCEDURE GetFile(msg: ARRAY OF CHAR;
  300.                   VAR cancel: BOOLEAN;
  301.                   VAR pathname: AccentString);
  302. (* IF cancel, get input file, else get output file. *)
  303.   VAR
  304.     button: INTEGER;
  305.     file: AccentString;
  306.  
  307.   BEGIN
  308.  
  309.     IF ~cancel THEN (* show output dialog *)
  310.       IF RsrcGAddr(RTree, OUTPUT, outputTree) = AESError THEN
  311.         crash("RsrcGAddr")
  312.       END;
  313.       button := OUTPUT;
  314.       i := GrafMouse(MOn,NIL);
  315.       DoDial(button,outputTree);
  316.       ClearScreen;
  317.       IF button = OUTSCRN THEN (* output to screen *)
  318.         cancel := TRUE; RETURN;
  319.       ELSIF button = OUTPRINT THEN (* output to printer *)
  320.         GEMDOSfn(prstat);
  321.         INLINE(pop,2);
  322.         button := SHORT(REG(D0));
  323.         IF button = 0 THEN
  324.           i := DoAlert(1,"[1][Your printer is not ready][oops]");
  325.           GetFile(msg,cancel,pathname);
  326.         ELSE
  327.           pathname := "PRN:"; cancel := FALSE;
  328.         END;
  329.         RETURN
  330.       END; (*IF button*)
  331.     END;(*IF ~cancel*)
  332.  
  333.     pathname := savePath;
  334.     file := saveFile;
  335.  
  336.     (* get path\filename via FselInput *)
  337.     i := 0; REPEAT INC(i) UNTIL ( (i >= HIGH(msg)) OR (msg[i] = 0C) );
  338.     i := 72 - (i DIV 2);
  339.     Write(33C); Write('Y'); Write(CHR(33)); Write(CHR(i));
  340.     Write(33C); Write('p');
  341.     WriteString(msg);
  342.     Write(33C); Write('q');
  343.     i := GrafMouse(MOn,NIL);
  344.     i := FselInput(pathname,file,button);
  345.     ClearScreen;
  346.     cancel := (button = 0);
  347.     IF cancel THEN
  348.       file := "";
  349.     ELSE
  350.       savePath := pathname;
  351.       saveFile := file;
  352.     END;
  353.     (* change default extender to selected filename *)
  354.     i := 0; REPEAT INC(i) UNTIL pathname[i] = 0C;
  355.     REPEAT DEC(i) UNTIL pathname[i] = '\'; INC(i);
  356.     append(pathname,file,i);
  357. (*
  358.     IF ~cancel THEN
  359.       WriteString(pathname); WriteString(" selected"); WriteLn;
  360.     END;
  361. *)
  362.   END GetFile;
  363.  
  364. (*----------------------------------------------------------------*)
  365.  
  366. PROCEDURE GetArgs(VAR args: AccentString);
  367.   VAR n,pos: CARDINAL;
  368.   BEGIN
  369.  
  370.     (* show options dialog *)
  371.     IF RsrcGAddr(RTree, optionsIndex, optionsTree) = AESError THEN
  372.        crash("RsrcGAddr") END;
  373.     i := GrafMouse(MOn,NIL);
  374.     DoDial(optionsIndex,optionsTree);
  375.     ClearScreen;
  376.  
  377.     (* convert accentOptions bitmap to string of option characters *)
  378.     args := "-"; pos := 1;
  379.     FOR n := STUT TO RANDOM DO
  380.       IF n IN accentOptions THEN
  381.         args[pos]:= accentChoices[n]; INC(pos);
  382.       END;
  383.     END;
  384.  
  385.     (* no options chosen, alert the user *)
  386.     IF pos = 1 THEN
  387.       i := DoAlert(2,"[1][You need to pick an option][OK|no I don't]");
  388.       IF i = 2 THEN GEMTerm END; (* the default - in case you lose your mouse *)
  389.       FOR i := 0 TO HIGH(args) DO args[i] := 0C END;
  390.       GetArgs(args);
  391.     ELSE
  392.       args[pos] := 0C;
  393.     END;
  394.  
  395.   END GetArgs;
  396.     
  397. (*----------------------------------------------------------------*)
  398.  
  399. PROCEDURE GEMTerm;
  400.   BEGIN
  401.     i := RsrcFree();
  402.     i := ApplExit();
  403.     GEMDOSfn(term0);
  404.   END GEMTerm;
  405.  
  406. (*================================================================*)
  407.  
  408. BEGIN (* AccentObjects *)
  409.  
  410.   GetDefaults; (* GEM Init code in ShowTitle *)
  411.  
  412. END AccentObjects.
  413.